home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / databa_1 / database.bas next >
Encoding:
BASIC Source File  |  1999-07-10  |  14.2 KB  |  387 lines
  1. Attribute VB_Name = "DataBaseApp"
  2. ' DataBaseApp.bas
  3. '
  4. ' By Herman Liu
  5. '
  6. ' An extract from an actual application of mine (with modifications to reduce extra features,
  7. ' e.g. option to use query, allowance for change of fields, and search facilities).
  8. ' -----------------------------------------------------------------------------------------
  9. ' -----------------------------------------------------------------------------------------
  10. ' PURPOSES:
  11. ' (1) To show how to use the ADO Schema to obtain a list of tables of a database.
  12. ' (2) To show how to provide a re-usable single form (the same form can be used for any
  13. '     MDB file name, and another form can be used to display as many tables as there are
  14. '     in that database. Otherwise, you will need 10 forms if there are 10 tables).
  15. ' (3) To show the possible techniques to enable opening several tables on the screen in
  16. '     the same session (using the same form) yet without conflict.
  17. ' (4) To show how to display various attributes/properties in descriptive text which is
  18. '     more understandable, rather than the VB's original numeric codes.
  19. '
  20. ' REMARKS:
  21. ' MDI form
  22. '   "Window" menu is provided so that you can switch between tables opened, if you
  23. '       open more than one on the screen.
  24. ' TABLES form
  25. '   (1) Double click a field name will display field properties (alternatively highlight
  26. '       that field name and click "Field Property" button).
  27. '   (2) Double click a table name will invokd the GRID form (alternatively highlight
  28. '       that table name and click "Table" button).
  29. ' GRID form
  30. '   (1) Click the tiny colored buttons below the Grid will show various attributes/
  31. '       properties.
  32. ' -----------------------------------------------------------------------------------------
  33. '
  34.  
  35. Option Explicit
  36.  
  37. Public gFileSpec As String               ' Filespec of MDB
  38. Public gTableName As String              ' Table name of selected MDB
  39. Public gstrFields() As String
  40. Public gstrFieldsOrig() As String
  41.  
  42. Public gfso As FileSystemObject
  43. Public gcdg As Object
  44.  
  45. Public gAcnn As adodb.Connection
  46. Public gstrCNN As String
  47.  
  48. ' Exclude fields for null terminated string and fields for pictures
  49. Public Const gconexcludeFieldTypes = "  8/128/204/205"
  50.  
  51.  
  52.  
  53. Sub Main()
  54.     Set gfso = New FileSystemObject
  55.     Set gcdg = frmFrame.CommonDialog1
  56.     
  57.     gFileSpec = ""
  58.     gTableName = ""
  59.     
  60.     frmFrame.Show
  61. End Sub
  62.  
  63.  
  64.  
  65. Sub DBFilesMDBproc()
  66.     On Error GoTo errhandler
  67.     
  68.     ' Obtain gFileSpec
  69.     Dim i As Integer
  70.     If GetFileSpec("(*.mdb)|*.mdb") = True Then
  71.          If UCase(Right(gFileSpec, 4)) <> ".MDB" Then
  72.              MsgBox "Please select a .MDB file"
  73.              Exit Sub
  74.          End If
  75.          
  76.          Set gAcnn = New adodb.Connection
  77.          gAcnn.CursorLocation = adUseClient
  78.          gstrCNN = "PROVIDER=Microsoft.Jet.OLEDB.4.0;" & _
  79.             "Data Source=" & gFileSpec & ";"
  80.  
  81.             ' Only gAcnn, not gRcnn
  82.          If (gAcnn.Errors.Count > 0) Then
  83.              ' Just Display The First Error In The Collection
  84.             MsgBox "Error: " & gAcnn.Errors(0).Description, _
  85.                  0, "Connect Error!"
  86.             Exit Sub
  87.          End If
  88.          
  89.          frmTablesTVW.Show
  90.     End If
  91.     Exit Sub
  92.     
  93.   ' Provided a way to exit, if error occurred in called form
  94.   ' forcing it to be closed
  95. errhandler:
  96.     ErrMsgProc "basMain DBFilesMDBProc"
  97. End Sub
  98.  
  99.  
  100.  
  101.  
  102. Function GetFileSpec(ByVal strFilter As String) As Boolean
  103.     On Error GoTo errhandler
  104.  
  105.     Dim tmpfile As String
  106.     tmpfile = gFileSpec
  107.    
  108.     Do
  109.         frmFrame.CommonDialog1.CancelError = True
  110.         frmFrame.CommonDialog1.FileName = tmpfile
  111.         frmFrame.CommonDialog1.Filter = strFilter
  112.         frmFrame.CommonDialog1.ShowOpen
  113.         
  114.         If frmFrame.CommonDialog1.FileName = "" Then
  115.             Exit Do
  116.         End If
  117.     
  118.         tmpfile = frmFrame.CommonDialog1.FileName
  119.         
  120.         If gfso.FileExists(tmpfile) = True Then
  121.             Exit Do
  122.         End If
  123.         
  124.         MsgBox "File specification not found.  Please re-try"
  125.     Loop
  126.     
  127.     If tmpfile <> "" Then
  128.         gFileSpec = tmpfile
  129.         GetFileSpec = True
  130.     Else
  131.         GetFileSpec = False
  132.     End If
  133.     
  134.     Exit Function
  135.     
  136. errhandler:
  137.    GetFileSpec = False
  138.    If Err.Number <> 32755 Then
  139.        ErrMsgProc "basMain GetFileSpec"
  140.    End If
  141. End Function
  142.  
  143.  
  144.  
  145. Sub ErrMsgProc(mMsg As String)
  146.     MsgBox mMsg & vbCrLf & Err.Number & Space(5) & Err.Description
  147. End Sub
  148.  
  149.  
  150.  
  151. ' Convert the numeric value returned by DB to Enum, so
  152. ' that at least the user could have a guess of what it is.
  153. Function ConvType(ByVal TypeVal As Long) As String
  154.   Select Case TypeVal
  155.       Case adBigInt                    ' 20
  156.          ConvType = "adBigInt"
  157.       Case adBinary                    ' 128
  158.          ConvType = "adBinary"
  159.       Case adBoolean                   ' 11
  160.          ConvType = "adBoolean"
  161.       Case adBSTR                      ' 8 i.e. null terminated string
  162.          ConvType = "adBSTR"
  163.       Case adChar                      ' 129
  164.          ConvType = "adChar"
  165.       Case adCurrency                  ' 6
  166.          ConvType = "adCurrency"
  167.       Case adDate                      ' 7
  168.          ConvType = "adDate"
  169.       Case adDBDate                    ' 133
  170.          ConvType = "adDBDate"
  171.       Case adDBTime                    ' 134
  172.          ConvType = "adDBTime"
  173.       Case adDBTimeStamp               ' 135
  174.          ConvType = "adDBTimeStamp"
  175.       Case adDecimal                   ' 14
  176.          ConvType = "adDecimal"
  177.       Case adDouble                    ' 5
  178.          ConvType = "adDouble"
  179.       Case adEmpty                     ' 0
  180.          ConvType = "adEmpty"
  181.       Case adError                     ' 10
  182.          ConvType = "adError"
  183.       Case adGUID                      ' 72
  184.          ConvType = "adGUID"
  185.       Case adIDispatch                 ' 9
  186.          ConvType = "adIDispatch"
  187.       Case adInteger                   ' 3
  188.          ConvType = "adInteger"
  189.       Case adIUnknown                  ' 13
  190.          ConvType = "adIUnknown"
  191.       Case adLongVarBinary             ' 205
  192.          ConvType = "adLongVarBinary"
  193.       Case adLongVarChar               ' 201
  194.          ConvType = "adLongVarChar"
  195.       Case adLongVarWChar              ' 203
  196.          ConvType = "adLongVarWChar"
  197.       Case adNumeric                  ' 131
  198.          ConvType = "adNumeric"
  199.       Case adSingle                    ' 4
  200.          ConvType = "adSingle"
  201.       Case adSmallInt                  ' 2
  202.          ConvType = "adSmallInt"
  203.       Case adTinyInt                   ' 16
  204.          ConvType = "adTinyInt"
  205.       Case adUnsignedBigInt            ' 21
  206.          ConvType = "adUnsignedBigInt"
  207.       Case adUnsignedInt               ' 19
  208.          ConvType = "adUnsignedInt"
  209.       Case adUnsignedSmallInt          ' 18
  210.          ConvType = "adUnsignedSmallInt"
  211.       Case adUnsignedTinyInt           ' 17
  212.          ConvType = "adUnsignedTinyInt"
  213.       Case adUserDefined               ' 132
  214.          ConvType = "adUserDefined"
  215.       Case adVarBinary                 ' 204
  216.          ConvType = "adVarBinary"
  217.       Case adVarChar                   ' 200
  218.          ConvType = "adVarChar"
  219.       Case adVariant                   ' 12
  220.          ConvType = "adVariant"
  221.       Case adVarWChar                  ' 202
  222.          ConvType = "adVarWChar"
  223.       Case adWChar                     ' 130
  224.          ConvType = "adWChar"
  225.    End Select
  226. End Function
  227.  
  228.  
  229.  
  230. Function ConvAttr(ByVal mAttr As Long) As String
  231.     ' Note value of mAttr is often a combination of several values
  232.     ' hence chances are "Unknown" in the following
  233.     Select Case mAttr
  234.        Case (mAttr And adFldMayDefer)
  235.            ConvAttr = "adFldMayDefer "            '2
  236.        Case (mAttr And adFldUpdatable)
  237.            ConvAttr = "adFldUpdatable "           '4
  238.        Case (mAttr And adFldUnknownUpdatable)
  239.            ConvAttr = "adFldUnknownUpdatable "    '8
  240.        Case (mAttr And adFldFixed)
  241.            ConvAttr = "adFldFixed "               '16
  242.        Case (mAttr And adFldIsNullable)
  243.            ConvAttr = "adFldIsNullable "          '32
  244.        Case (mAttr And adFldMayBeNull)
  245.            ConvAttr = "adFldMayBeNull "           '64
  246.        Case (mAttr And adFldLong)
  247.            ConvAttr = "adFldLong "                '128
  248.        Case (mAttr And adFldRowID)
  249.            ConvAttr = "adFldRowID "               '256
  250.        Case (mAttr And adFldRowVersion)
  251.            ConvAttr = "adFldRowVersion "          '512
  252.        Case (mAttr And adFldCacheDeferred)
  253.            ConvAttr = "adFldCacheDeferred "       '4096
  254.        Case Else
  255.            ConvAttr = "Attr unknown"
  256.     End Select
  257. End Function
  258.  
  259.  
  260.  
  261. Function ConvLockType(ByVal mLockType) As String
  262.     Select Case mLockType
  263.        Case (mLockType And adLockReadOnly)
  264.            ConvLockType = "adLockReadOnly"           ' 1
  265.        Case (mLockType And adLockPessimistic)
  266.            ConvLockType = "adLockPessimistic"        ' 2
  267.        Case (mLockType And adLockOptimistic)
  268.            ConvLockType = "adLockOptimistic"         ' 3
  269.        Case (mLockType And adLockBatchOptimistic)
  270.            ConvLockType = "adLockBatchOptimistic"    ' 4
  271.        Case Else
  272.            ConvLockType = "(Unknown)"
  273.     End Select
  274. End Function
  275.  
  276.  
  277.  
  278. Function ConvEditMode(ByVal mEditMode) As String
  279.     Select Case mEditMode
  280.        Case (mEditMode And adEditNone)
  281.            ConvEditMode = "adEditNone"               ' 0
  282.        Case (mEditMode And adEditInProgress)
  283.            ConvEditMode = "adEditInProgress"         ' 1
  284.        Case (mEditMode And adEditAdd)
  285.            ConvEditMode = "adEditAdd"                ' 2
  286.        Case Else
  287.            ConvEditMode = "(Unknown)"
  288.     End Select
  289. End Function
  290.  
  291.  
  292.  
  293.  
  294. Function ConvState(ByVal mState) As String
  295.     Select Case mState
  296.        Case (mState And adStateClosed)
  297.            ConvState = "adStateClosed"           ' 0, default
  298.        Case (mState And adStateOpen)
  299.            ConvState = "adStateOpen"             '
  300.        Case (mState And adStateConnecting)
  301.            ConvState = "adStateConnecting"
  302.        Case (mState And adStateExecuting)
  303.            ConvState = "adStateExecuting"
  304.        Case (mState And adStateFetching)
  305.            ConvState = "adStateFetching"
  306.        Case Else
  307.            ConvState = "(Unknown)"
  308.     End Select
  309. End Function
  310.  
  311.  
  312.  
  313. 'Returns a sum of one or more of the RecordStatusEnum values.
  314. 'Use the Status property to see what changes are pending for records
  315. 'modified during batch updating. You can also use the Status property
  316. 'to view the status of records that fail during bulk operations, such
  317. 'as when you call the Resync, UpdateBatch, or CancelBatch methods on
  318. 'a Recordset object, or set the Filter property on a Recordset object
  319. 'to an array of bookmarks. With this property, you can determine how
  320. 'a given record failed and resolve it accordingly.
  321. Function ConvStatus(ByVal mStatus) As String
  322.     ' Because one or more values can be present, accumulate the string
  323.     Dim tmp As String
  324.     tmp = ""
  325.     Select Case mStatus
  326.        Case (mStatus And adRecOK)
  327.           ConvStatus = "adRecOK"           ' 0 Record was successfully update
  328.        Case (mStatus And adRecNew)
  329.           ConvStatus = "adRecNew"          ' 1 Is new
  330.        Case (mStatus And adRecModified)
  331.           ConvStatus = "adRecModified"     ' 2 Was modified.
  332.        Case (mStatus And adRecDeleted)
  333.           ConvStatus = "adRecDeleted"      ' 4 Was deleted.
  334.        Case (mStatus And adRecUnmodified)
  335.           ConvStatus = "adRecUnmodified"   ' 8 Was not modified.
  336.        Case (mStatus And adRecInvalid)
  337.           ConvStatus = "adRecInvalid"      ' 16 Was not saved because its bookmark is invalid.
  338.        Case (mStatus And adRecMultipleChanges)
  339.           ConvStatus = "adRecMultipleChanges"  ' 64 Not saved because it would have affected multiple records.
  340.        Case (mStatus And adRecPendingChanges)
  341.           ConvStatus = "adRecPendingChanges"   ' 128 Was not saved because it refers to a pending insert.
  342.        Case (mStatus And adRecCanceled)
  343.           ConvStatus = "adRecCanceled"         ' 256 Was not saved because the operation was canceled.
  344.        Case (mStatus And adRecCantRelease)
  345.           ConvStatus = "adRecCantRelease"      ' 1024 Was not saved because of existing record locks.
  346.        Case (mStatus And adRecConcurrencyViolation)
  347.           ConvStatus = "adRecConcurrencyViolation"   ' 2048 Was not saved because optimistic concurrency was in use.
  348.        Case (mStatus And adRecIntegrityViolation)
  349.           ConvStatus = "adRecIntegrityViolation"     ' 4096 Was not saved because the user violated integrity constraints.
  350.        Case (mStatus And adRecMaxChangesExceeded)
  351.           ConvStatus = "adRecMaxChangesExceeded"     ' 8192 Was not saved because there were too many pending changes.
  352.        Case (mStatus And adRecObjectOpen)
  353.           ConvStatus = "adRecObjectOpen"             ' 16384 Was not saved because of a conflict with an open storage object.
  354.        Case (mStatus And adRecOutOfMemory)
  355.           ConvStatus = "adRecOutOfMemory"            ' 32768 Was not saved because the computer has run out of memory.
  356.        Case (mStatus And adRecPermissionDenied)
  357.           ConvStatus = "adRecPermissionDenied"       ' 65536 Was not saved because the user has insufficient permissions.
  358.        Case (mStatus And adRecSchemaViolation)
  359.           ConvStatus = "adRecSchemaViolation"        ' 131072 Was not saved because it violates structure of underlying database.
  360.        Case (mStatus And adRecDBDeleted)
  361.           ConvStatus = "adRecDBDeleted"              ' 262144 The record has already been deleted from the data source.
  362.        Case Else
  363.           ConvStatus = "A combination of serveral status present"
  364.    End Select
  365. End Function
  366.  
  367.  
  368.  
  369. Function ConvCursorType(ByVal mCursorType) As String
  370.     Select Case mCursorType
  371.        Case (mCursorType And adOpenForwardOnly)
  372.            ConvCursorType = "adOpenForwardOnly"      ' 0
  373.        Case (mCursorType And adOpenKeyset)
  374.            ConvCursorType = "adOpenKeyset"           ' 1
  375.        Case (mCursorType And adOpenDynamic)
  376.            ConvCursorType = "adOpenKynamic"          ' 2
  377.        Case (mCursorType And adOpenStatic)
  378.            ConvCursorType = "adOpenStatic"           ' 3
  379.        Case Else
  380.            ConvCursorType = "(Unknown)"
  381.     End Select
  382. End Function
  383.  
  384.  
  385.  
  386.  
  387.